;;;; Simplifiy the ast by removing empty nodes and unused variables.
;;;;
;;;; This has become a grab-bag of random optimizations.

(in-package :mezzano.compiler)

(defvar *prohibit-tagbody-fusion* nil)

(defun simplify (lambda architecture)
  (declare (ignore architecture))
  (detect-uses lambda)
  (simp-form lambda))

(defgeneric simp-form (form))

(defgeneric fetch-inner-the-type (form)
  (:documentation "Descend FORM as fetch the type of the outermost THE form type.
Returns NIL if there is no THE form.")
  (:method ((form ast-node)) nil))

(defmethod fetch-inner-the-type ((form ast-the))
  (ast-the-type form))

(defmethod fetch-inner-the-type ((form ast-block))
  (fetch-inner-the-type (ast-body form)))

(defmethod fetch-inner-the-type ((form ast-let))
  (fetch-inner-the-type (ast-body form)))

(defmethod fetch-inner-the-type ((form ast-multiple-value-bind))
  (fetch-inner-the-type (ast-body form)))

(defmethod fetch-inner-the-type ((form ast-multiple-value-prog1))
  (fetch-inner-the-type (ast-value-form form)))

(defmethod fetch-inner-the-type ((form ast-progn))
  (cond ((ast-forms form)
         (fetch-inner-the-type (first (last (ast-forms form)))))
        (t nil)))

(defmethod fetch-inner-the-type ((form ast-unwind-protect))
  (fetch-inner-the-type (ast-protected-form form)))

(defun hoist-the-form-to-edge (form)
  (cond ((typep form 'ast-the)
         form)
        (t
         (let ((the-type (fetch-inner-the-type form)))
           (cond (the-type
                  (change-made)
                  (ast `(the ,the-type ,form) form))
                 (t form))))))

(defmethod simp-form ((form ast-block))
  (cond
    ;; Unused blocks get reduced to progn.
    ((eql (lexical-variable-use-count (info form)) 0)
     (change-made)
     (simp-form (body form)))
    ;; (block foo (return-from foo form)) => (block foo form)
    ((and (typep (body form) 'ast-return-from)
          (eql (info form) (info (body form))))
     (change-made)
     (setf (body form) (simp-form (value (body form))))
     form)
    (t (setf (body form) (simp-form (body form)))
       form)))

(defmethod simp-form ((form ast-function))
  form)

(defmethod simp-form ((form ast-go))
  ;; HACK: Update the tagbody location part after tagbodies have merged.
  (when (tagbody-information-p (info form))
    (setf (info form) (go-tag-tagbody (target form))))
  form)

;;; Hoist LET/M-V-B/PROGN forms out of IF tests.
;;;  (if (let bindings form1 ... formn) then else)
;;; =>
;;;  (let bindings form1 ... (if formn then else))
;;; Beware when hoisting LET/M-V-B, must not hoist special bindings.
(defun hoist-form-out-of-if (form)
  (let ((test-form (test form)))
    (typecase test-form
      (ast-let
       (when (let-binds-special-variable-p test-form)
         (return-from hoist-form-out-of-if nil))
       (ast `(let ,(bindings test-form)
               (if ,(body test-form)
                   ,(if-then form)
                   ,(if-else form)))
            form))
      (ast-multiple-value-bind
       (when (find-if (lambda (x) (typep x 'special-variable))
                      (bindings test-form))
         (return-from hoist-form-out-of-if nil))
       (ast `(multiple-value-bind ,(bindings test-form)
                 ,(value-form test-form)
               (if ,(body test-form)
                   ,(if-then form)
                   ,(if-else form)))
            form))
      (ast-progn
       (if (forms test-form)
           (ast `(progn ,@(append (butlast (forms test-form))
                                  (list `(if ,(first (last (forms test-form)))
                                             ,(if-then form)
                                             ,(if-else form)))))
                form)
           ;; No body forms, must evaluate to NIL!
           ;; Fold away the IF.
           (if-else form))))))

(defmethod simp-form ((form ast-if))
  (let ((new-form (hoist-form-out-of-if form)))
    (cond (new-form
           (change-made)
           (simp-form new-form))
          ((typep (test form) 'ast-if)
           ;; Rewrite (if (if ...) ...).
           (let ((test-form (test form)))
             (change-made)
             (simp-form (ast `(block if-escape
                                (tagbody if-tagbody
                                   (entry (if ,(test test-form)
                                              ;; Special case here to catch (if a a b), generated by OR.
                                              ,(if (eql (test test-form) (if-then test-form))
                                                   `(go then-tag if-tagbody)
                                                   `(if ,(if-then test-form)
                                                        (go then-tag if-tagbody)
                                                        (go else-tag if-tagbody)))
                                              (if ,(if-else test-form)
                                                  (go then-tag if-tagbody)
                                                  (go else-tag if-tagbody))))
                                   (then-tag (return-from if-escape ,(if-then form) if-escape))
                                   (else-tag (return-from if-escape ,(if-else form) if-escape))))
                             form))))
          ((and (typep (if-then form) 'ast-go)
                (typep (if-else form) 'ast-go)
                (eql (target (if-then form)) (target (if-else form)))
                (eql (info (if-then form)) (info (if-else form))))
           ;; Rewrite (if x (go A-TAG) (go A-TAG)) => (progn x (go A-TAG))
           (change-made)
           (simp-form (ast `(progn ,(test form) ,(if-then form))
                           form)))
          ((eql (if-then form) (if-else form))
           ;; Rewrite (if x foo foo) => (progn x foo)
           (change-made)
           (simp-form (ast `(progn ,(test form) ,(if-then form))
                           form)))
          ((typep (test form) 'ast-quote)
           ;; (if 'not-nil then else) => then
           ;; (if 'nil then else) => else
           (change-made)
           (simp-form (if (not (eql (value (test form)) 'nil))
                          (if-then form)
                          (if-else form))))
          ((and (typep (unwrap-the (test form)) 'ast-call)
                (member (name (unwrap-the (test form))) '(sys.int::binary-+)))
           ;; (if (known-to-return-true) then else) => (progn (known-to-return-true) then)
           (change-made)
           (simp-form (ast `(progn ,(test form) ,(if-then form))
                           form)))
          (t
           (setf (test form) (simp-form (test form))
                 (if-then form) (simp-form (if-then form))
                 (if-else form) (simp-form (if-else form)))
           form))))

(defun pure-p (form)
  (let ((unwrapped (unwrap-the form)))
    (or (lambda-information-p unwrapped)
        (typep unwrapped 'ast-quote)
        (typep unwrapped 'ast-function)
        (and (lexical-variable-p unwrapped)
             (localp unwrapped)
             (eql (lexical-variable-write-count unwrapped) 0))
        ;; FIXME: This needs to check the number of arguments.
        (and (typep unwrapped 'ast-call)
             (or (member (ast-name unwrapped) *pure-functions* :test #'equal)
                 (and (match-optimize-settings unwrapped '((= safety 0)))
                      (member (ast-name unwrapped) *pure-functions-at-low-safety* :test #'equal)))
             (every #'pure-p (ast-arguments unwrapped))))))

(defmethod simp-form ((form ast-let))
  ;; Merge nested LETs when possible, do not merge special bindings!
  (do ((nested-form (body form) (body form)))
      ((or (not (typep (unwrap-the nested-form) 'ast-let))
           (let-binds-special-variable-p form)
           (and (bindings (unwrap-the nested-form))
                (typep (first (first (bindings (unwrap-the nested-form)))) 'special-variable))))
    (change-made)
    (if (null (bindings (unwrap-the nested-form)))
        (setf (body form) (ast `(the ,(unwrapped-the-type nested-form)
                                     ,(body (unwrap-the nested-form)))
                               nested-form))
        (setf (bindings form) (nconc (bindings form) (list (first (bindings (unwrap-the nested-form)))))
              (bindings (unwrap-the nested-form)) (rest (bindings (unwrap-the nested-form))))))
  ;; Remove unused values with no side-effects.
  (setf (bindings form) (remove-if (lambda (b)
                                     (let ((var (first b))
                                           (val (second b)))
                                       (cond ((and (lexical-variable-p var)
                                                   (pure-p val)
                                                   (eql (lexical-variable-use-count var) 0))
                                              (change-made)
                                              t)
                                             (t nil))))
                                   (bindings form)))
  (dolist (b (bindings form))
    (setf (second b) (simp-form (hoist-the-form-to-edge (second b)))))
  (setf (body form) (simp-form (body form)))
  (when (not (let-binds-special-variable-p form))
    ;; Rewrite (let (... (foo ([progn,let] x y)) ...) ...) to (let (...) ([progn,let] x (let ((foo y) ...) ...))) when possible.
    (loop
       for binding-position from 0
       for (variable initform) in (bindings form)
       when (typep initform 'ast-progn)
       do
         (change-made)
         (return-from simp-form
           (simp-form
            (ast `(let ,(subseq (bindings form) 0 binding-position)
                    (progn
                      ,@(butlast (ast-forms initform))
                      (let ((,variable ,(first (last (ast-forms initform))))
                            ,@(subseq (bindings form) (1+ binding-position)))
                        ,(ast-body form))))
                 form)))
       when (and (typep initform 'ast-let)
                 (not (let-binds-special-variable-p initform)))
       do
         (change-made)
         (return-from simp-form
           (simp-form
            (ast `(let (,@(subseq (bindings form) 0 binding-position)
                        ,@(bindings initform)
                        (,variable ,(ast-body initform))
                        ,@(subseq (bindings form) (1+ binding-position)))
                    ,(ast-body form))
                 form))))
    ;; Rewrite (let (... (foo initform) ...) ...) to (let (...) (progn initform (let (...) ...))) when foo is unused.
    (loop
       for binding-position from 0
       for (variable initform) in (bindings form)
       when (zerop (lexical-variable-use-count variable))
       do
         (change-made)
         (return-from simp-form
           (simp-form
            (ast `(let ,(subseq (bindings form) 0 binding-position)
                    (progn
                      ,initform
                      (let ,(subseq (bindings form) (1+ binding-position))
                        ,(ast-body form))))
                 form)))))
  ;; Remove the LET if there are no values.
  (cond ((bindings form)
         form)
        (t
         (change-made)
         (body form))))

(defun let-binds-special-variable-p (let-form)
  (some (lambda (x) (typep (first x) 'special-variable))
        (bindings let-form)))

(defmethod simp-form ((form ast-multiple-value-bind))
  ;; If no variables are used, or there are no variables then
  ;; remove the form.
  (cond ((every (lambda (var)
                  (and (lexical-variable-p var)
                       (zerop (lexical-variable-use-count var))))
                (bindings form))
         (change-made)
         (simp-form (ast `(progn ,(value-form form)
                                 ,(body form))
                         form)))
        ;; M-V-B forms with only one variable can be lowered to LET.
        ((and (bindings form)
              (every (lambda (var)
                       (and (lexical-variable-p var)
                            (zerop (lexical-variable-use-count var))))
                     (rest (bindings form))))
         (change-made)
         (simp-form (ast `(let ((,(first (bindings form)) ,(value-form form)))
                            ,(body form))
                         form)))
        ;; Use an inner LET form to bind any special variables.
        ((some (lambda (x) (typep x 'special-variable)) (bindings form))
         (change-made)
         (let* ((specials (remove-if-not (lambda (x) (typep x 'special-variable))
                                         (bindings form)))
                (replacements (loop
                                 for s in specials
                                 collect (make-instance 'lexical-variable
                                                        :inherit s
                                                        :name (name s)
                                                        :definition-point *current-lambda*
                                                        :use-count 1)))
                ;; Also doubles up as an alist mapping specials to replacements.
                (bindings (mapcar #'list specials replacements)))
           (ast `(multiple-value-bind
                       ,(mapcar (lambda (var)
                                  (if (typep var 'special-variable)
                                      (second (assoc var bindings))
                                      var))
                                (bindings form))
                     ,(value-form form)
                     (let ,bindings
                       ,(simp-form (body form))))
                form)))
        ;; Rewrite (m-v-b (...) (let (...) ...) ...)
        ;; to (let (...) (m-v-b (...) ... ...)) when there are no
        ;; special bindings in the LET.
        ;; This puts the real values form closer to the M-V-B.
        ((and (typep (ast-value-form form) 'ast-let)
              (not (let-binds-special-variable-p (ast-value-form form))))
         (change-made)
         (ast `(let ,(ast-bindings (ast-value-form form))
                 (multiple-value-bind ,(ast-bindings form)
                     ,(simp-form (ast-body (ast-value-form form)))
                   ,(simp-form (ast-body form))))
              form))
        ;; Rewrite (m-v-b (bn...) (values vn...) ...)
        ;; to (let ((bn vn)...) ...)
        ((and (typep (ast-value-form form) 'ast-call)
              (eql (ast-name (value-form form)) 'values))
         (change-made)
         (let ((values (ast-arguments (ast-value-form form))))
           (ast `(let ,(loop
                          for b in (ast-bindings form)
                          collect (list b (if values
                                              (pop values)
                                              `'nil)))
                   (progn
                     ,@values
                     ,(ast-body form)))
                form)))
        (t
         (setf (value-form form) (simp-form (value-form form))
               (body form) (simp-form (body form)))
         form)))

(defmethod simp-form ((form ast-multiple-value-call))
  (setf (function-form form) (simp-form (function-form form))
        (value-form form) (simp-form (value-form form)))
  (when (typep (unwrap-the (function-form form)) '(or ast-quote ast-function lexical-variable lambda-information))
    ;; Shunt MVC downward.
    (let ((value-form (value-form form)))
      (cond ((typep value-form 'ast-progn)
             (change-made)
             (setf form
                   (simp-form
                    (ast `(progn
                            ,@(butlast (ast-forms value-form))
                            (multiple-value-call ,(function-form form)
                              ,(first (last (ast-forms value-form)))))
                         form))))
            ((and (typep value-form 'ast-let)
                  (not (let-binds-special-variable-p value-form)))
             (change-made)
             (setf form
                   (simp-form
                   (ast `(let ,(ast-bindings value-form)
                           (multiple-value-call ,(function-form form)
                             ,(ast-body value-form)))
                        form)))))))
  form)

(defmethod simp-form ((form ast-multiple-value-prog1))
  (setf (value-form form) (simp-form (value-form form))
        (body form) (simp-form (body form)))
  (cond ((typep (value-form form) 'ast-progn)
         ;; If the first form is a PROGN, then hoist all but the final value out.
         (change-made)
         (ast `(progn ,@(butlast (forms (value-form form)))
                      (multiple-value-prog1 ,(car (last (forms (value-form form))))
                        ,(body form)))
              form))
        ((typep (value-form form) 'ast-multiple-value-prog1)
         ;; If the first form is a M-V-PROG1, then splice it in.
         (change-made)
         (ast `(multiple-value-prog1 ,(value-form (value-form form))
                 (progn ,(body (value-form form))
                        ,(body form)))
              form))
        ((typep (body form) '(or ast-quote ast-function lexical-variable lambda-information))
         ;; If the body form is mostly constant, then kill this completely.
         (change-made)
         (value-form form))
        (t form)))

(defun simp-progn-body (x)
  ;; Merge nested progns, remove unused quote/function/lambda/variable forms
  ;; and eliminate code after return-from/go.
  (do* ((i x (rest i))
        (result (cons nil nil))
        (tail result))
       ((endp i)
        (cdr result))
    (let ((form (simp-form (first i))))
      (cond ((and (typep form 'ast-progn)
                  (forms form))
             ;; Non-empty PROGN.
             (change-made)
             ;; Rewrite ((progn v1 ... vn) . xn) to (v1 .... vn . xn).
             (setf (cdr tail) (simp-progn-body (forms form))
                   tail (last tail)))
            ((and (typep form 'ast-progn)
                  (not (forms form)))
             ;; Empty progn. Replace with 'NIL if at end.
             (change-made)
             (when (rest i)
               (setf (cdr tail) (cons (ast `(quote nil)) nil)
                     tail (cdr tail))))
            ((and (rest i) ; not at end.
                  (pure-p form))
             ;; This is a constantish value not at the end.
             ;; Remove it.
             (change-made))
            (t
             (setf (cdr tail) (cons form nil)
                   tail (cdr tail)))))))

(defmethod simp-form ((form ast-progn))
  (let ((new-forms (simp-progn-body (forms form))))
    (cond ((endp new-forms)
           ;; Flush empty PROGNs.
           (change-made)
           (ast `(quote nil) form))
          ((endp (rest new-forms))
           ;; Reduce single form PROGNs.
           (change-made)
           (first new-forms))
          (t
           (setf (forms form) new-forms)
           form))))

(defmethod simp-form ((form ast-quote))
  form)

(defmethod simp-form ((form ast-return-from))
  (setf (value form) (simp-form (value form))
        (info form) (simp-form (info form)))
  form)

(defmethod simp-form ((form ast-setq))
  (let ((unwrapped-val (unwrap-the (value form))))
    (cond ((and (typep unwrapped-val 'ast-let)
                (not (let-binds-special-variable-p unwrapped-val)))
           ;; (setq foo (let ... x)) => (let ... (setq foo x))
           (change-made)
           (let ((the-type (unwrapped-the-type (value form))))
             (simp-form
              (ast `(the ,the-type
                         (let ,(bindings unwrapped-val)
                           (setq ,(setq-variable form)
                                 (the ,the-type
                                      ,(body unwrapped-val)))))
                   unwrapped-val))))
          ((typep unwrapped-val 'ast-progn)
           ;; (setq foo (progn ... x)) => (progn ... (setq foo x))
           (change-made)
           (let ((the-type (unwrapped-the-type (value form))))
             (simp-form
              (ast `(the ,the-type
                         (progn
                           ,@(butlast (ast-forms unwrapped-val))
                           (setq ,(setq-variable form)
                                 (the ,the-type
                                      ,(first (last (ast-forms unwrapped-val)))))))
                   unwrapped-val))))
          (t
           (setf (value form) (simp-form (value form)))
           form))))

(defmethod simp-form ((form ast-tagbody))
  ;; Remove unused go-tags.
  (setf (tagbody-information-go-tags (info form))
        (remove-if (lambda (x) (eql (go-tag-use-count x) 0))
                   (tagbody-information-go-tags (info form))))
  (setf (statements form) (remove-if (lambda (x) (eql (go-tag-use-count (first x)) 0))
                                     (statements form)))
  ;; Try to merge any nested TAGBODYs.
  ;; Do this before simplification, because GO forms will need to be updated.
  (unless *prohibit-tagbody-fusion*
    (let ((new-stmts '()))
      (loop
         for (go-tag statement) in (statements form)
         do (typecase statement
              (ast-progn
               (cond ((some (lambda (x) (typep x 'ast-tagbody)) (forms statement))
                      ;; Contains at least one nested TAGBODY.
                      (let ((current-go-tag go-tag)
                            (accum '()))
                        (dolist (subform (forms statement))
                          (typecase subform
                            (ast-tagbody
                             ;; Reached a tagbody.
                             ;; Jump from the current tag to the tagbody's entry tag.
                             (push (ast `(go ,(first (first (statements subform))) ,(info form))
                                        subform)
                                   accum)
                             (incf (go-tag-use-count (first (first (statements subform)))))
                             ;; Finish accumulating the forms before this tagbody.
                             (push (list current-go-tag (ast `(progn ,@(reverse accum)) subform)) new-stmts)
                             ;; Create a new go-tag that is *after* this tagbody.
                             (setf current-go-tag (make-instance 'go-tag
                                                                 :inherit subform
                                                                 :name (gensym "tagbody-resume")
                                                                 :use-count 1
                                                                 :tagbody (info form))
                                   accum '())
                             (push current-go-tag (tagbody-information-go-tags (info form)))
                             ;; Splice tagbody in, and after each statement add a GO to
                             ;; the resume tag.
                             (loop
                                for (new-go-tag new-statement) in (statements subform)
                                do
                                  (push new-go-tag (tagbody-information-go-tags (info form)))
                                  (setf (go-tag-tagbody new-go-tag) (info form))
                                  (incf (go-tag-use-count current-go-tag))
                                  (push (list new-go-tag (ast `(progn
                                                                 ,new-statement
                                                                 (go ,current-go-tag ,(info form)))
                                                              new-statement))
                                        new-stmts)))
                            (t ;; Normal form, accumulate it.
                             (push subform accum))))
                        ;; Finish the current tag.
                        (push (list current-go-tag (ast `(progn ,@(reverse accum) 'nil) statement)) new-stmts)))
                     (t (push (list go-tag statement) new-stmts))))
              (ast-tagbody
               ;; Get this one.
               (push (list go-tag (ast `(go ,(first (first (statements statement))) ,(info form)) statement)) new-stmts)
               (incf (go-tag-use-count (first (first (statements statement)))))
               (loop
                  for (new-go-tag new-statement) in (statements statement)
                  do
                    (push new-go-tag (tagbody-information-go-tags (info form)))
                    (setf (go-tag-tagbody new-go-tag) (info form))
                    (push (list new-go-tag new-statement) new-stmts)))
              (t (push (list go-tag statement) new-stmts))))
      (setf (statements form) (reverse new-stmts))))
  ;; Simplify forms.
  (setf (statements form) (loop
                             for (go-tag statement) in (statements form)
                             collect (list go-tag (simp-form statement))))
  ;; If the entry go-tag has one use, and there aren't any more statements, then
  ;; reduce this to a progn.
  (cond ((and (eql (go-tag-use-count (first (first (statements form)))) 1)
              (endp (rest (statements form))))
         (change-made)
         (ast `(progn
                 ,(second (first (statements form)))
                 'nil)
              form))
        (t form)))

(defun values-type-p (type)
  (and (consp type)
       (eql (first type) 'values)))

;; FIXME: This isn't quite right, it produces a result type that is the
;; the minimum and maximum of each input type. If the input types are
;; disjoint then it should produced an AND type.
(defun merge-real-type-values (value-1 value-2 op)
  (cond ((and (eql value-1 '*) (eql value-2 '*))
         '*)
        ((eql value-1 '*) value-2)
        ((eql value-2 '*) value-1)
        ((and (consp value-1) (consp value-2))
         ;; Both exclusive.
         (if (funcall op (first value-1) (first value-2))
             value-1
             value-2))
        ((consp value-1)
         (cond ((= (first value-1) value-2)
                ;; Equal, pick the exclusive bound.
                value-1)
               ((funcall op (first value-1) value-2)
                value-1)
               (t
                value-2)))
        ((consp value-2)
         (cond ((= value-1 (first value-2))
                ;; Equal, pick the exclusive bound.
                value-2)
               ((funcall op value-1 (first value-2))
                value-1)
               (t
                value-2)))
        (t
         ;; Both inclusive
         (if (funcall op value-1 value-2)
             value-1
             value-2))))

(defun merge-the-types-non-values (type-1 type-2)
  "Merge TYPE-1 and TYPE-2 together, not dealing with values types."
  (when (and (consp type-1) (member (first type-1) '(and or)) (endp (cddr type-1)))
    (setf type-1 (second type-1)))
  (when (and (consp type-2) (member (first type-2) '(and or)) (endp (cddr type-2)))
    (setf type-2 (second type-2)))
  (cond ((equal type-1 type-2)
         type-1)
        ((eql type-1 't) type-2)
        ((eql type-2 't) type-1)
        ((and (or (and (consp type-1) (eql (first type-1) 'integer))
                  (eql type-1 'integer))
              (or (and (consp type-2) (eql (first type-2) 'integer))
                  (eql type-2 'integer)))
         (destructuring-bind (&optional (min-1 '*) (max-1 '*))
             (if (consp type-1) (rest type-1) '())
           (destructuring-bind (&optional (min-2 '*) (max-2 '*))
               (if (consp type-2) (rest type-2) '())
             (let ((new-min (merge-real-type-values min-1 min-2 #'>))
                   (new-max (merge-real-type-values max-1 max-2 #'<)))
               `(integer ,new-min ,new-max)))))
        ;; Check if one type is an AND type that contains the other type.
        ((and (consp type-1)
              (eql (first type-1) 'and)
              (some (lambda (x) (equal x type-2)) (rest type-1)))
         type-1)
        ((and (consp type-2)
              (eql (first type-2) 'and)
              (some (lambda (x) (equal x type-1)) (rest type-2)))
         type-2)
        ;; Check if one type is an AND type and avoid creating deeply nested
        ;; AND types.
        ((and (consp type-1)
              (eql (first type-1) 'and)
              (consp type-2)
              (eql (first type-2) 'and))
         `(and ,@(rest type-1) ,@(rest type-2)))
        ((and (consp type-1)
              (eql (first type-1) 'and))
         `(and type-2 ,@(rest type-1)))
        ((and (consp type-2)
              (eql (first type-2) 'and))
         `(and type-1 ,@(rest type-2)))
        (t
         `(and ,type-1 ,type-2))))

(defun test-merge-integer-types ()
  (labels ((check1 (x y expected)
             (let ((result (merge-the-types-non-values x y)))
               (format t "~:S ~:S => ~:S: ~A~%" x y expected
                       (if (equal result expected)
                           "pass" "FAIL"))
               (when (not (equal result expected))
                 (format t "   got ~:S~%" result))))
           (check2 (x y expected)
             (check1 x y expected)
             (check1 y x expected)))
    (check1 '(integer * *) '(integer * *) '(integer * *))
    (check2 '(integer 0 *) '(integer * *) '(integer 0 *))
    (check2 '(integer * 0) '(integer * *) '(integer * 0))
    (check2 '(integer 0 *) '(integer * 0) '(integer 0 0))
    (check2 '(integer * 0) '(integer 0 *) '(integer 0 0))
    (check2 '(integer (0) *) '(integer * *) '(integer (0) *))
    (check2 '(integer * (0)) '(integer * *) '(integer * (0)))
    (check2 '(integer (0) *) '(integer * (0)) '(integer (0) (0)))
    (check2 '(integer * (0)) '(integer (0) *) '(integer (0) (0)))
    (check2 '(integer 0 *) '(integer 0 *) '(integer 0 *))
    (check2 '(integer (0) *) '(integer 0 *) '(integer (0) *))
    (check2 '(integer (0) *) '(integer (0) *) '(integer (0) *))
    (check2 '(integer 0 *) '(integer -1 *) '(integer 0 *))
    (check2 '(integer * 0) '(integer * 1) '(integer * 0))
    (check2 '(integer (0) *) '(integer (-1) *) '(integer (0) *))
    (check2 '(integer * (0)) '(integer * (1)) '(integer * (0)))
    (check2 '(integer (0) *) '(integer -1 *) '(integer (0) *))
    (check2 '(integer * (0)) '(integer * 1) '(integer * (0)))
    (check2 '(integer 0 *) '(integer (-1) *) '(integer 0 *))
    (check2 '(integer * 0) '(integer * (1)) '(integer * 0))
    ))

(defun merge-the-types (type-1 type-2)
  (cond ((or (values-type-p type-1)
             (values-type-p type-2))
         (when (not (values-type-p type-1))
           (setf type-1 `(values ,type-1)))
         (when (not (values-type-p type-2))
           (setf type-2 `(values ,type-2)))
         (do ((i (rest type-1) (rest i))
              (j (rest type-2) (rest j))
              (result '()))
             ((and (endp i)
                   (endp j))
              (cond ((endp (rest result))
                     (first result))
                    (t
                     `(values ,@(reverse result)))))
           (push (merge-the-types-non-values (if i (first i) 't)
                                             (if j (first j) 't))
                 result)))
        (t
         (merge-the-types-non-values type-1 type-2))))

(defmethod simp-form ((form ast-the))
  (cond ((compiler-valid-subtypep 't (the-type form))
         (change-made)
         (simp-form (value form)))
        ((typep (value form) 'ast-the)
         (change-made)
         (setf (the-type form) (merge-the-types (the-type form)
                                                (the-type (value form)))
               (value form) (simp-form (value (value form))))
         form)
        ((and (typep (value form) 'ast-let)
              (not (typep (ast-body (value form)) 'ast-the)))
         ;; Turn (the ... (let (...) ...)) inside-out: (let (...) (the ... ...))
         (change-made)
         (setf (ast-body (value form)) (ast `(the ,(the-type form)
                                                  ,(ast-body (value form)))
                                            form))
         (setf (value form) (simp-form (value form)))
         form)
        ((and (typep (value form) 'ast-progn)
              (ast-forms (value form))
              (not (typep (first (last (ast-forms (value form)))) 'ast-the)))
         ;; Turn (the ... (progn ...)) inside-out: (progn ... (the ... ...))
         (change-made)
         (let ((last (last (ast-forms (value form)))))
           (setf (first last)
                 (ast `(the ,(the-type form) ,(first last)))))
         (setf (value form) (simp-form (value form)))
         form)
        ((typep (value form) 'ast-if)
         ;; Push type declarations into IF arms.
         (when (not (typep (if-then (value form)) 'ast-the))
           (change-made)
           (setf (if-then (value form)) (ast `(the ,(the-type form)
                                                   ,(if-then (value form)))
                                             (if-then (value form)))))
         (when (not (typep (if-else (value form)) 'ast-the))
           (change-made)
           (setf (if-else (value form)) (ast `(the ,(the-type form)
                                                   ,(if-else (value form)))
                                             (if-else (value form)))))
         (setf (value form) (simp-form (value form)))
         form)
        (t
         (setf (value form) (simp-form (value form)))
         form)))

(defmethod simp-form ((form ast-unwind-protect))
  (setf (protected-form form) (simp-form (protected-form form))
        (cleanup-function form) (simp-form (cleanup-function form)))
  form)

(defun eq-comparable-p (value)
  (or (not (numberp value))
      (fixnump value) ;; Use fixnump, not the type fixnum to avoid x-compiler problems.
      (typep value 'single-float)
      (typep value 'short-float)))

(defun simp-eql (form)
  (when (eql (list-length (arguments form)) 2)
    ;; (eql X X) => T
    (when (eql (first (arguments form)) (second (arguments form)))
      (change-made)
      (return-from simp-eql (ast ''t form)))
    ;; (eql constant non-constant) => (eql non-constant constant)
    (when (and (quoted-form-p (first (arguments form)))
               (not (quoted-form-p (second (arguments form)))))
      (change-made)
      (rotatef (first (arguments form)) (second (arguments form))))
    ;; (eql x eq-comparable-constant) => (eq x eq-comparable-constant)
    (when (and (quoted-form-p (second (arguments form)))
               (eq-comparable-p (value (second (arguments form)))))
      (change-made)
      (setf (name form) 'eq)))
  form)

(defun simp-ash (form)
  (cond ((and (eql (list-length (arguments form)) 2)
              (or (and (typep (second (arguments form)) 'ast-the)
                       (match-optimize-settings form '((= safety 0) (= speed 3)))
                       (compiler-valid-type-equal-p (ast-the-type (second (arguments form))) '(eql 0)))
                  (and (quoted-form-p (second (arguments form)))
                       (eql (value (second (arguments form))) 0))))
         ;; (ash value 0) => (progn (type-check value integer) value)
         (change-made)
         (return-from simp-ash
           (if (match-optimize-settings form '((= safety 0) (= speed 3)))
               (ast `(let ((value ,(first (arguments form))))
                       (progn
                         ,(second (arguments form))
                         value))
                    form)
               (ast `(let ((value ,(first (arguments form))))
                       (progn
                         ,(second (arguments form))
                         (if (call integerp value)
                             value
                             (call sys.int::raise-type-error value 'integer))))
                    form))))
        ((and (eql (list-length (arguments form)) 2)
              (quoted-form-p (second (arguments form)))
              (integerp (value (second (arguments form)))))
         ;; (ash value known-count) => left-shift or right-shift.
         (change-made)
         (cond ((plusp (value (second (arguments form))))
                (setf (name form) 'mezzano.runtime::left-shift))
               (t
                (setf (name form) 'mezzano.runtime::right-shift
                      (arguments form) (list (first (arguments form))
                                             (make-instance 'ast-quote
                                                            :inherit form
                                                            :value (- (value (second (arguments form))))))))))
        ((and (eql (list-length (arguments form)) 2)
              (match-optimize-settings form '((= safety 0) (= speed 3)))
              (typep (second (arguments form)) 'ast-the)
              (compiler-valid-subtypep (ast-the-type (second (arguments form))) '(integer 0)))
         ;; (ash value known-non-negative-integer) => left-shift
         (change-made)
         (setf (name form) 'mezzano.runtime::left-shift))
        ((and (eql (list-length (arguments form)) 2)
              (match-optimize-settings form '((= safety 0) (= speed 3)))
              (typep (second (arguments form)) 'ast-the)
              (compiler-valid-subtypep (ast-the-type (second (arguments form))) '(integer * 0)))
         ;; (ash value known-non-positive-integer) => right-shift
         (change-made)
         (setf (name form) 'mezzano.runtime::right-shift
               (arguments form) (list (first (arguments form))
                                      (ast `(call sys.int::binary-- '0 ,(second (arguments form)))
                                           form)))))
  form)

(defparameter *mod-n-arithmetic-functions*
  '(sys.int::binary-+ sys.int::binary--
    sys.int::binary-* sys.int::%truncate rem
    sys.int::binary-logior sys.int::binary-logxor sys.int::binary-logand
    mezzano.runtime::left-shift mezzano.runtime::%fixnum-left-shift))

(defun unwrap-progn (form)
  (loop
     while (and (typep form 'ast-progn)
                (ast-forms form))
     do (setf form (first (last (ast-forms form))))
     finally (return form)))

(defun mod-n-transform-candidate-p (value mask mask-type)
  ;; Mask must be a known positive power-of-two minus 1 fixnum.
  (when (not (and (typep mask 'ast-quote)
                  (typep (ast-value mask) mask-type)
                  (> (ast-value mask) 0)
                  (zerop (logand (ast-value mask)
                                 (1+ (ast-value mask))))))
    (return-from mod-n-transform-candidate-p
      nil))
  (let ((value (unwrap-progn value)))
    (when (and (typep value 'ast-call)
               (eql (name value) 'sys.int::%truncate)
               (eql (length (arguments value)) 2)
               (match-transform-argument 'float (first (arguments value)))
               (match-transform-argument '(eql 1) (second (arguments value))))
      ;; Conversion from float to integer.
      (return-from mod-n-transform-candidate-p
        t))
    (when (or (and (typep value 'ast-call)
                   (member (name value) '(mezzano.simd:mmx-vector-value mezzano.simd::%mmx-vector-value))
                   (eql (length (arguments value)) 1)
                   (match-transform-argument 'mezzano.simd:mmx-vector (first (arguments value))))
              (and (typep value 'ast-call)
                   (member (name value) '(mezzano.simd:sse-vector-value mezzano.simd::%sse-vector-value))
                   (eql (length (arguments value)) 1)
                   (match-transform-argument 'mezzano.simd:sse-vector (first (arguments value)))))
      ;; Conversion from mmx/sse--vector to integer.
      (return-from mod-n-transform-candidate-p
        t))
    ;; The value must be a call to one of the arithmetic functions.
    ;; Both sides must be fixnums. This will cause the fixnum arithmetic
    ;; transforms to fire, and the calls to be transformed to their
    ;; fixnum-appropriate functions.
    (when (not (and (typep value 'ast-call)
                    (member (name value) *mod-n-arithmetic-functions*)
                    (eql (length (arguments value)) 2)
                    (match-transform-argument mask-type (first (arguments value)))
                    (match-transform-argument mask-type (second (arguments value)))))
      (return-from mod-n-transform-candidate-p
        nil)))
  t)

;;; Fast(ish) mod-n arithmetic.
;;; (logand (1- some-known-fixnum-power-of-two) (+ (the fixnum foo) (the fixnum bar)))
;;;   =>
;;; (logand (1- some-known-fixnum-power-of-two) (the fixnum (+ (the fixnum foo) (the fixnum bar))))
;;; Any fixnum LOGAND a fixnum will produce a fixnum result.
;;; This relies on the arithmetic function being transformed to a function
;;; that really does only produce a fixnum result.
(defun simp-logand (form)
  (let ((lhs (first (arguments form)))
        (rhs (second (arguments form))))
    (cond ((mod-n-transform-candidate-p rhs lhs 'fixnum)
           ;; Insert appropriate THE form.
           (change-made)
           (setf (second (arguments form)) (ast `(the fixnum ,rhs)
                                                rhs)))
          ((mod-n-transform-candidate-p lhs rhs 'fixnum)
           ;; Insert appropriate THE form.
           (change-made)
           (setf (first (arguments form)) (ast `(the fixnum ,lhs)
                                               lhs)))
          ((mod-n-transform-candidate-p rhs lhs '(unsigned-byte 64))
           ;; Insert appropriate THE form.
           (change-made)
           (setf (second (arguments form)) (ast `(the (unsigned-byte 64) ,rhs)
                                                rhs)))
          ((mod-n-transform-candidate-p lhs rhs '(unsigned-byte 64))
           ;; Insert appropriate THE form.
           (change-made)
           (setf (first (arguments form)) (ast `(the (unsigned-byte 64) ,lhs)
                                               lhs))))
    form))

(defun simp-array-rank (form)
  (let* ((array (first (arguments form)))
         (type (if (typep array 'ast-the)
                   (ast-the-type array)
                   't)))
    (cond ((and (consp type)
                ;; Arrays never change rank.
                (member (first type) '(array simple-array)))
           (let ((dims (nth-value 1 (sys.int::parse-array-type type))))
             ;; Some kind of array. See if the rank is known.
             (cond ((listp dims)
                    ;; It is! Replace with the known length.
                    (ast `(progn ,array
                                 ',(length dims))
                         form))
                   (t form))))
          (t
           form))))

(defun simp-array-dimension (form)
  (let* ((array (first (arguments form)))
         (axis (second (arguments form)))
         (type (if (typep array 'ast-the)
                   (ast-the-type array)
                   't)))
    (cond ((and (typep axis 'ast-quote)
                (integerp (ast-value axis))
                (consp type)
                (member (first type) '(simple-array array)))
           (multiple-value-bind (element-type dims)
               (sys.int::parse-array-type type)
             (let* ((rank (if (listp dims)
                              (length dims)
                              -1))
                    (axis (ast-value axis))
                    (dim (if (<= 0 axis (1- rank))
                             (elt dims axis)
                             nil)))
               (cond ((integerp dim)
                      ;; This axis has a known dimension.
                      (ast `(progn ,array
                                   ',dim)
                           form))
                     ((and (eql dim '*)
                           (not (eql element-type '*)))
                      ;; This axis is unknown, but the axis is valid.
                      (let ((not-stringp (compiler-valid-not-subtypep element-type 'character))
                            (simplep (eql (first type) 'simple-array)))
                        (cond ((and (eql rank 1)
                                    ;; Must be a simple array.
                                    simplep
                                    ;; Strings are always represented as complex arrays,
                                    ;; even when they're simple
                                    not-stringp)
                               (ast `(the fixnum (call sys.int::%object-header-data ,array))
                                    form))
                              ((or (not (eql rank 1))
                                   (not not-stringp))
                               ;; 1D arrays *may* be simple and have a different representation,
                               ;; so need to go through the full call...
                               (ast `(the fixnum (call sys.int::%object-ref-t
                                                       ,array
                                                       ',(+ sys.int::+complex-array-axis-0+ axis)))
                                    form))
                              (t form))))
                     (t form)))))
          (t
           form))))

(defun extract-list-like-forms (form)
  "If FORM is a list-like series of calls, then return the objects that would form the elements of the list.
First return value is a list of elements, second is the final dotted component (if any), third is true if a dynamic extent list is involved at any point."
  (setf form (unwrap-the form))
  (typecase form
    (ast-call
     (case (name form)
       ((list dx-list)
        (values (arguments form) nil (eql (name form) 'dx-list)))
       ((list* dx-list*)
        (multiple-value-bind (tail-components tail-tail dx-p)
            (extract-list-like-forms (first (last (arguments form))))
          (values (append (butlast (arguments form))
                          tail-components)
                  tail-tail
                  (or dx-p (eql (name form) 'dx-list*)))))
       ((cons)
        (multiple-value-bind (tail-components tail-tail dx-p)
            (extract-list-like-forms (second (arguments form)))
          (values (append (list (first (arguments form)))
                          tail-components)
                  tail-tail
                  dx-p)))
       ((copy-list)
        (extract-list-like-forms (first (arguments form))))
       (t
        (values nil form))))
    (ast-quote
     (let ((val (ast-value form))
           (fast (ast-value form))
           (elts '()))
       (loop
          (cond ((null val)
                 (return (values (reverse elts) nil)))
                ((not (consp val))
                 (return (values (reverse elts)
                                 (ast `(quote ,val) form))))
                ((and elts (eql fast val))
                 ;; Slow pointer met fast pointer, this is a circular list.
                 ;; Give up.
                 (return (values nil form)))
                (t
                 ;; Cons, accumulate elements.
                 (push (ast `(quote ,(first val)) form) elts)
                 (setf val (rest val))
                 ;; Check for circular lists.
                 (when (consp fast)
                   (setf fast (rest fast))
                   (when (consp fast)
                     (setf fast (rest fast)))))))))
    (t
     (values nil form))))

(defun simp-%apply (form)
  (multiple-value-bind (list-body list-tail)
      (extract-list-like-forms (second (arguments form)))
    (cond ((not list-tail)
           ;; (%apply foo (list ...)) => (%funcall foo ...)
           (change-made)
           (setf (name form) 'mezzano.runtime::%funcall
                 (arguments form) (append (list (first (arguments form)))
                                          list-body))
           (simp-form form))
          (t form))))

(defun local-inlining-permitted-p (form)
  ;; This call can be inlined it has not been locally declared notline.
  (not (eql (second (assoc (ast-name form) (ast-inline-declarations form) :test #'equal)) 'notinline)))

(defun struct-slot-accessor-name (slot-def fn-namespace)
  (let ((accessor (mezzano.runtime::location-type-accessor
                   (mezzano.runtime::location-type
                    (mezzano.clos:slot-definition-location slot-def)))))
    (if fn-namespace
        (list fn-namespace accessor)
        accessor)))

(defun struct-slot-accessor-index (slot-def)
  (let ((loc (mezzano.clos:slot-definition-location slot-def)))
    (if (eql (mezzano.runtime::location-type loc) mezzano.runtime::+location-type-t+)
        (mezzano.runtime::location-offset-t loc)
        (mezzano.runtime::location-offset loc))))

(defun struct-slot-access-form (slot-def object fn-namespace &rest additional-args)
  `(the ,(mezzano.clos:slot-definition-type slot-def)
        (call ,(struct-slot-accessor-name slot-def fn-namespace)
              ,@additional-args
              ,object
              ',(struct-slot-accessor-index slot-def))))

(defun find-struct-slot (struct-name slot-name)
  (when (and (typep struct-name 'ast-quote)
             (typep (ast-value struct-name) 'symbol))
    (let ((struct-class (sys.int::get-structure-type (ast-value struct-name) nil)))
      (and struct-class
           (typep slot-name 'ast-quote)
           (find (ast-value slot-name)
                 (mezzano.clos:class-slots struct-class)
                 :key #'mezzano.clos:slot-definition-name)))))

(defun struct-type-test-form (object struct)
  (if (mezzano.clos:class-sealed struct)
      `(if (call sys.int::%value-has-tag-p ,object ',sys.int::+tag-object+)
           (call sys.int::%fast-instance-layout-eq-p
                 ,object
                 ',(mezzano.runtime::%make-instance-header
                    (mezzano.clos:class-layout struct)))
           'nil)
      `(if ,(struct-slot-access-form (find 'sys.int::obsolete
                                           (mezzano.clos:class-slots
                                            (sys.int::get-structure-type 'sys.int::layout))
                                           :key #'mezzano.clos:slot-definition-name)
                                     `',(mezzano.clos:class-layout struct)
                                     nil)
           'nil
           (if (call sys.int::%value-has-tag-p ,object ',sys.int::+tag-object+)
               (if (call sys.int::%fast-instance-layout-eq-p
                         ,object
                         ',(mezzano.runtime::%make-instance-header
                            (mezzano.clos:class-layout struct)))
                   't
                   (call sys.int::structure-type-p ,object ',struct))
               'nil))))

(defun simplify-struct-slot (form)
  (change-made)
  (destructuring-bind (object structure-name slot-name)
      (arguments form)
    (let ((slot-def (find-struct-slot structure-name slot-name))
          (struct (sys.int::get-structure-type (ast-value structure-name))))
      (cond ((match-optimize-settings form '((= safety 0) (= speed 3)))
             (ast (struct-slot-access-form slot-def object nil)
                  form))
            (t
             (ast `(let ((obj ,object))
                     (if ,(struct-type-test-form 'obj struct)
                         ,(struct-slot-access-form slot-def 'obj nil)
                         (notinline-call sys.int::%struct-slot
                                         obj
                                         ',(ast-value structure-name)
                                         ',(ast-value slot-name))))
                  form))))))

(defun simplify-setf-struct-slot (form)
  (change-made)
  (destructuring-bind (value object structure-name slot-name)
      (arguments form)
    (let ((slot-def (find-struct-slot structure-name slot-name))
          (struct (sys.int::get-structure-type (ast-value structure-name))))
      (cond ((match-optimize-settings form '((= safety 0) (= speed 3)))
             (ast (struct-slot-access-form slot-def object 'setf value)
                  form))
            (t
             (ast `(let ((val ,value)
                         (obj ,object))
                     (if ,(struct-type-test-form 'obj struct)
                         (progn
                           (if (source-fragment (typep val ',(mezzano.clos:slot-definition-type slot-def)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error val ',(mezzano.clos:slot-definition-type slot-def))
                                 (call sys.int::%%unreachable)))
                           ,(struct-slot-access-form slot-def 'obj 'setf 'val))
                         (notinline-call (setf sys.int::%struct-slot)
                                         val
                                         obj
                                         ',(ast-value structure-name)
                                         ',(ast-value slot-name))))
                  form))))))

(defun simplify-cas-struct-slot (form)
  (change-made)
  (destructuring-bind (old new object structure-name slot-name)
      (arguments form)
    (let ((slot-def (find-struct-slot structure-name slot-name))
          (struct (sys.int::get-structure-type (ast-value structure-name))))
      (cond ((match-optimize-settings form '((= safety 0) (= speed 3)))
             (ast `(let ((old ,old)
                         (new ,new)
                         (obj ,object))
                     ,(struct-slot-access-form slot-def 'obj 'sys.int::cas 'old 'new))
                  form))
            (t
             (ast `(let ((old ,old)
                         (new ,new)
                         (obj ,object))
                     (if ,(struct-type-test-form 'obj struct)
                         (progn
                           (if (source-fragment (typep old ',(mezzano.clos:slot-definition-type slot-def)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error old ',(mezzano.clos:slot-definition-type slot-def))
                                 (call sys.int::%%unreachable)))
                           (if (source-fragment (typep new ',(mezzano.clos:slot-definition-type slot-def)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error new ',(mezzano.clos:slot-definition-type slot-def))
                                 (call sys.int::%%unreachable)))
                           ,(struct-slot-access-form slot-def 'obj 'sys.int::cas 'old 'new))
                         (notinline-call (sys.int::cas sys.int::%struct-slot)
                                         old
                                         new
                                         obj
                                         ',(ast-value structure-name)
                                         ',(ast-value slot-name))))
                form))))))

(defun test-atomic-fixnum-op-struct-slot-transform-viability (form)
  (destructuring-bind (object structure-name slot-name value)
      (arguments form)
    (declare (ignore object value))
    (let ((slot (find-struct-slot structure-name slot-name)))
      (and
       ;; Structures & slots must be known.
       slot
       ;; Must be writable.
       (not (mezzano.clos:structure-slot-definition-read-only slot))
       ;; Must be exactly of type fixnum.
       (compiler-valid-type-equal-p (mezzano.clos:slot-definition-type slot)
                                    'fixnum)))))

(defun atomic-op-for-atomic-struct-slot-op (struct-slot-op)
  (ecase struct-slot-op
    (sys.int::%atomic-fixnum-add-struct-slot
     'sys.int::%atomic-fixnum-add-object)
    (sys.int::%atomic-fixnum-logand-struct-slot
     'sys.int::%atomic-fixnum-logand-object)
    (sys.int::%atomic-fixnum-logior-struct-slot
     'sys.int::%atomic-fixnum-logior-object)
    (sys.int::%atomic-fixnum-logxor-struct-slot
     'sys.int::%atomic-fixnum-logxor-object)))

(defun simplify-atomic-fixnum-op-struct-slot (form)
  (change-made)
  (destructuring-bind (object structure-name slot-name value)
      (arguments form)
    (let ((slot-def (find-struct-slot structure-name slot-name))
          (struct (sys.int::get-structure-type (ast-value structure-name)))
          (op (atomic-op-for-atomic-struct-slot-op (name form))))
      (cond ((match-optimize-settings form '((= safety 0) (= speed 3)))
             (ast `(let ((obj ,object)
                         (value ,value))
                     (call ,op obj ',(struct-slot-accessor-index slot-def) value))
                  form))
            (t
             (ast `(let ((obj ,object)
                         (value ,value))
                     (if ,(struct-type-test-form 'obj struct)
                         (progn
                           (if (source-fragment (typep value 'fixnum))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error value 'fixnum)
                                 (call sys.int::%%unreachable)))
                           (call ,op obj ',(struct-slot-accessor-index slot-def) value))
                         (notinline-call ,(name form)
                                         obj
                                         ',(ast-value structure-name)
                                         ',(ast-value slot-name)
                                         value)))
                form))))))

(defun test-atomic-swap-struct-slot-transform-viability (form)
  (destructuring-bind (object structure-name slot-name value)
      (arguments form)
    (declare (ignore object value))
    (let ((slot (find-struct-slot structure-name slot-name)))
      (and
       ;; Structures & slots must be known.
       slot
       ;; Must be writable.
       (not (mezzano.clos:structure-slot-definition-read-only slot))))))

(defun simplify-atomic-swap-struct-slot (form)
  (change-made)
  (destructuring-bind (object structure-name slot-name value)
      (arguments form)
    (let ((slot-def (find-struct-slot structure-name slot-name))
          (struct (sys.int::get-structure-type (ast-value structure-name))))
      (cond ((match-optimize-settings form '((= safety 0) (= speed 3)))
             (ast `(let ((obj ,object)
                         (value ,value))
                     (call sys.int::%xchg-object
                           obj
                           ',(struct-slot-accessor-index slot-def)
                           value))
                  form))
            (t
             (ast `(let ((obj ,object)
                         (value ,value))
                     (if ,(struct-type-test-form 'obj struct)
                         (progn
                           (if (source-fragment (typep value ',(mezzano.clos:slot-definition-type slot-def)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error value ',(mezzano.clos:slot-definition-type slot-def))
                                 (call sys.int::%%unreachable)))
                           (call sys.int::%xchg-object
                                 obj
                                 ',(struct-slot-accessor-index slot-def)
                                 value))
                         (notinline-call ,(name form)
                                         obj
                                         ',(ast-value structure-name)
                                         ',(ast-value slot-name)
                                         value)))
                form))))))

(defun test-dcas-struct-slot-transform-viability
    (structure-name-1 slot-name-1 structure-name-2 slot-name-2)
  (let ((slot-1 (find-struct-slot structure-name-1 slot-name-1))
        (slot-2 (find-struct-slot structure-name-2 slot-name-2)))
    (when (and
           ;; Both structures & slots must be known.
           slot-1 slot-2
           ;; Both must be writable.
           (not (mezzano.clos:structure-slot-definition-read-only slot-1))
           (not (mezzano.clos:structure-slot-definition-read-only slot-2))
           ;; They must be DCAS pairs.
           (eql (mezzano.clos:structure-slot-definition-dcas-sibling slot-1)
                (mezzano.clos:slot-definition-name slot-2))
           (eql (mezzano.clos:slot-definition-name slot-1)
                (mezzano.clos:structure-slot-definition-dcas-sibling slot-2)))
      ;; The structures must be the same, or one must be a child of the other.
      (let ((struct-1 (sys.int::get-structure-type (ast-value structure-name-1)))
            (struct-2 (sys.int::get-structure-type (ast-value structure-name-2))))
        (or (eql struct-1 struct-2)
            (member struct-2 (mezzano.clos:class-precedence-list struct-1))
            (member struct-1 (mezzano.clos:class-precedence-list struct-2)))))))

(defun generate-dcas-form (slot-1 slot-2 object old-1 old-2 new-1 new-2)
  (let ((loc-1 (mezzano.clos:slot-definition-location slot-1))
        (loc-2 (mezzano.clos:slot-definition-location slot-2)))
    (assert (eql (mezzano.runtime::location-type loc-1) mezzano.runtime::+location-type-t+))
    (assert (eql (mezzano.runtime::location-type loc-2) mezzano.runtime::+location-type-t+))
    (let ((ofs-1 (mezzano.runtime::location-offset-t loc-1))
          (ofs-2 (mezzano.runtime::location-offset-t loc-2)))
      (cond ((eql (1+ ofs-1) ofs-2)
             (assert (oddp ofs-1))
             ;; FIXME: The result from %DCAS-OBJECT should be wrapped in
             ;; THE, but the compiler has issues with VALUES types here.
             `(call sys.int::%dcas-object
                    ,object ',ofs-1
                    ,old-1 ,old-2 ,new-1 ,new-2))
            ((eql (1+ ofs-2) ofs-1)
             ;; Inverted slots.
             (assert (oddp ofs-2))
             `(multiple-value-bind (successp value-2 value-1)
                  (call sys.int::%dcas-object
                        ,object ',ofs-2
                        ,old-2 ,old-1 ,new-2 ,new-1)
                (call values
                      successp
                      (the ,(mezzano.clos:slot-definition-type slot-1) value-1)
                      (the ,(mezzano.clos:slot-definition-type slot-2) value-2))))
            (t
             (error "Discontigious dcas siblings?"))))))

(defun simplify-dcas-struct-slot (form)
  (change-made)
  (destructuring-bind (object
                       structure-name-1 slot-name-1
                       structure-name-2 slot-name-2
                       old-1 old-2
                       new-1 new-2)
      (arguments form)
    (let* ((slot-def-1 (find-struct-slot structure-name-1 slot-name-1))
           (slot-def-2 (find-struct-slot structure-name-2 slot-name-2))
           (struct-1 (sys.int::get-structure-type (ast-value structure-name-1)))
           (struct-2 (sys.int::get-structure-type (ast-value structure-name-2)))
           ;; Get the most relevant struct type.
           (struct (if (member struct-2 (mezzano.clos:class-precedence-list struct-1))
                       struct-2
                       struct-1)))
      (cond ((match-optimize-settings form '((= safety 0) (= speed 3)))
             (ast `(let ((old-1 ,old-1) (old-2 ,old-2)
                         (new-1 ,new-1) (new-2 ,new-2)
                         (obj ,object))
                     ,(generate-dcas-form slot-def-1 slot-def-2 'obj 'old-1 'old-2 'new-1 'new-2))
                  form))
            (t
             (ast `(let ((old-1 ,old-1) (old-2 ,old-2)
                         (new-1 ,new-1) (new-2 ,new-2)
                         (obj ,object))
                     (if ,(struct-type-test-form 'obj struct)
                         (progn
                           (if (source-fragment (typep old-1 ',(mezzano.clos:slot-definition-type slot-def-1)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error old-1 ',(mezzano.clos:slot-definition-type slot-def-1))
                                 (call sys.int::%%unreachable)))
                           (if (source-fragment (typep old-2 ',(mezzano.clos:slot-definition-type slot-def-2)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error old-2 ',(mezzano.clos:slot-definition-type slot-def-2))
                                 (call sys.int::%%unreachable)))
                           (if (source-fragment (typep new-1 ',(mezzano.clos:slot-definition-type slot-def-1)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error new-1 ',(mezzano.clos:slot-definition-type slot-def-1))
                                 (call sys.int::%%unreachable)))
                           (if (source-fragment (typep new-2 ',(mezzano.clos:slot-definition-type slot-def-2)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error new-2 ',(mezzano.clos:slot-definition-type slot-def-2))
                                 (call sys.int::%%unreachable)))
                           ,(generate-dcas-form slot-def-1 slot-def-2 'obj 'old-1 'old-2 'new-1 'new-2))
                         (notinline-call sys.int::%dcas-struct-slot
                                         obj
                                         ',(ast-value structure-name-1) ',(ast-value slot-name-1)
                                         ',(ast-value structure-name-2) ',(ast-value slot-name-2)
                                         old-1 old-2
                                         new-1 new-2)))
                form))))))

(defun simplify-struct-vector-slot-check-bounds (index slot-def)
  `(tagbody foo
      (ENTRY (if (call sys.int::fixnump ,index)
                 (if (call sys.int::binary-<= '0 ,index)
                     (if (call sys.int::binary-< ,index ',(mezzano.clos:structure-slot-definition-fixed-vector slot-def))
                         (go OK foo)
                         (go BAD foo))
                     (go BAD foo))
                 (go BAD foo)))
      (BAD (call error '"Struct fixed-vector out of bounds"))
      (OK 'nil)))

(defun struct-vector-slot-index-fast (slot-def index)
  `(call sys.int::binary-+
         (the fixnum ',(struct-slot-accessor-index slot-def))
         (the fixnum
              (call sys.int::binary-*
                    (the fixnum ,index)
                    ',(mezzano.runtime::location-type-scale
                       (mezzano.runtime::location-type
                        (mezzano.clos:slot-definition-location slot-def)))))))

(defun struct-vector-slot-index (slot-def index)
  `(call sys.int::binary-+
         ',(struct-slot-accessor-index slot-def)
         (call sys.int::binary-*
               ,index
               ',(mezzano.runtime::location-type-scale
                  (mezzano.runtime::location-type
                   (mezzano.clos:slot-definition-location slot-def))))))

(defun struct-vector-slot-access-form (slot-def object fn-namespace index fastp &rest additional-args)
  `(the ,(mezzano.clos:slot-definition-type slot-def)
        (call ,(struct-slot-accessor-name slot-def fn-namespace)
              ,@additional-args
              ,object
              ,(if fastp
                   (struct-vector-slot-index-fast slot-def index)
                   (struct-vector-slot-index slot-def index)))))

(defun simplify-struct-vector-slot (form)
  (change-made)
  (destructuring-bind (object structure-name slot-name index)
      (arguments form)
    (let ((slot-def (find-struct-slot structure-name slot-name))
          (struct (sys.int::get-structure-type (ast-value structure-name))))
      (cond ((match-optimize-settings form '((= safety 0) (= speed 3)))
             (ast (struct-vector-slot-access-form slot-def object nil index t)
                  form))
            (t
             (ast `(let ((obj ,object)
                         (ind ,index))
                     (progn
                       ,(simplify-struct-vector-slot-check-bounds 'ind slot-def)
                       (if ,(struct-type-test-form 'obj struct)
                           ,(struct-vector-slot-access-form slot-def 'obj nil 'ind nil)
                           (notinline-call sys.int::%struct-vector-slot
                                           obj
                                           ',(ast-value structure-name)
                                           ',(ast-value slot-name)
                                           ind))))
                  form))))))

(defun simplify-setf-struct-vector-slot (form)
  (change-made)
  (destructuring-bind (value object structure-name slot-name index)
      (arguments form)
    (let ((slot-def (find-struct-slot structure-name slot-name))
          (struct (sys.int::get-structure-type (ast-value structure-name))))
      (cond ((match-optimize-settings form '((= safety 0) (= speed 3)))
             (ast (struct-vector-slot-access-form slot-def object 'setf index t value)
                  form))
            (t
             (ast `(let ((val ,value)
                         (obj ,object)
                         (ind ,index))
                     (progn
                       ,(simplify-struct-vector-slot-check-bounds 'ind slot-def)
                       (if ,(struct-type-test-form 'obj struct)
                           (progn
                             (if (source-fragment (typep val ',(mezzano.clos:slot-definition-type slot-def)))
                                 'nil
                                 (progn
                                   (call sys.int::raise-type-error val ',(mezzano.clos:slot-definition-type slot-def))
                                   (call sys.int::%%unreachable)))
                             ,(struct-vector-slot-access-form slot-def 'obj 'setf 'ind nil 'val))
                           (notinline-call (setf sys.int::%struct-vector-slot)
                                           val
                                           obj
                                           ',(ast-value structure-name)
                                           ',(ast-value slot-name)
                                           ind))))
                form))))))

(defun simplify-cas-struct-vector-slot (form)
  (change-made)
  (destructuring-bind (old new object structure-name slot-name index)
      (arguments form)
    (let ((slot-def (find-struct-slot structure-name slot-name))
          (struct (sys.int::get-structure-type (ast-value structure-name))))
      (cond ((match-optimize-settings form '((= safety 0) (= speed 3)))
             (ast `(let ((old ,old)
                         (new ,new)
                         (obj ,object)
                         (ind ,index))
                     ,(struct-vector-slot-access-form slot-def 'obj 'sys.int::cas 'ind t 'old 'new))
                form))
          (t
           (ast `(let ((old ,old)
                       (new ,new)
                       (obj ,object)
                       (ind ,index))
                   (progn
                     ,(simplify-struct-vector-slot-check-bounds 'ind slot-def)
                     (if ,(struct-type-test-form 'obj struct)
                         (progn
                           (if (source-fragment (typep old ',(mezzano.clos:slot-definition-type slot-def)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error new ',(mezzano.clos:slot-definition-type slot-def))
                                 (call sys.int::%%unreachable)))
                           (if (source-fragment (typep new ',(mezzano.clos:slot-definition-type slot-def)))
                               'nil
                               (progn
                                 (call sys.int::raise-type-error new ',(mezzano.clos:slot-definition-type slot-def))
                                 (call sys.int::%%unreachable)))
                           ,(struct-vector-slot-access-form slot-def 'obj 'sys.int::cas 'ind nil 'old 'new))
                         (notinline-call (sys.int::cas sys.int::%struct-vector-slot)
                                         old
                                         new
                                         obj
                                         ',(ast-value structure-name)
                                         ',(ast-value slot-name)
                                         ind))))
                form))))))

(defun integer-type-p (type)
  (or (eql type 'integer)
      (and (consp type)
           (eql (first type) 'integer))))

(defun fold-fixnum-<-2 (value bound direction)
  (destructuring-bind (&optional (min '*) (max '*))
      (if (consp bound) (rest bound) '())
    (cond ((or (not (integerp min))
               (not (integerp max)))
           ;; Don't deal with non-inclusive ranges.
           (values nil nil))
          ((funcall direction value min)
           (values nil t))
          ((funcall direction max value)
           (values t t))
          (t
           ;; Indeterminate.
           (values nil nil)))))

(defun fold-fixnum-<-1 (lhs rhs)
  (cond ((and (typep lhs 'ast-quote)
              (integerp (ast-value lhs))
              (typep rhs 'ast-the)
              (integer-type-p (ast-the-type rhs)))
         (multiple-value-bind (val successp)
             (fold-fixnum-<-2 (ast-value lhs) (ast-the-type rhs) #'<=)
           (values (not val) successp)))
        ((and (typep lhs 'ast-the)
              (integer-type-p (ast-the-type lhs))
              (typep rhs 'ast-quote)
              (integerp (ast-value rhs)))
         (fold-fixnum-<-2 (ast-value rhs) (ast-the-type lhs) #'>=))
        (t
         (values nil nil))))

(defun extract-integer-type-interval (form)
  "Extract an INTEGER type from FORM.
Returns if the type is valid, and the lower and upper bounds.
The bounds may be NIL, denoting the absence of a bound, or they may be
an integer. Both bounds are inclusive. The interval will always contain at
least one value."
  (cond ((and (typep form 'ast-quote)
              (integerp (ast-value form)))
         (values t (ast-value form) (ast-value form)))
        ((and (typep form 'ast-the)
              (eql (ast-the-type form) 'integer))
         (values t nil nil))
        ((and (typep form 'ast-the)
              (consp (ast-the-type form))
              (eql (first (ast-the-type form)) 'integer))
         (destructuring-bind (&optional (min '*) (max '*))
             (rest (ast-the-type form))
           ;; Convert bounds to inclusive and * to NIL.
           (cond ((consp min)
                  (setf min (1+ (first min))))
                 ((eql min '*)
                  (setf min nil)))
           (cond ((consp max)
                  (setf max (1- (first max))))
                 ((eql max '*)
                  (setf max nil)))
           (cond ((and min max (< max min))
                  ;; This is secretly the bottom type, contains no values!
                  nil)
                 (t
                  (values t min max)))))
        (t nil)))

(defun integer-interval-<-p (lhs-lower-bound lhs-upper-bound
                             rhs-lower-bound rhs-upper-bound)
  (cond ((< lhs-upper-bound rhs-lower-bound)
         (values t t))
        ((>= lhs-lower-bound rhs-upper-bound)
         (values t nil))
        (t nil)))

(defun test-integer-interval-<-p ()
  (dotimes (i 4)
    (dotimes (j 4)
      (dotimes (k 4)
        (dotimes (l 4)
          (when (and (<= i j) (<= k l))
            (let* ((lhs (loop for x from i to j collect x))
                   (rhs (loop for y from k to l collect y))
                   (res (loop for x in lhs appending
                             (loop for y in rhs collecting (list x y (not (not (< x y)))))))
                   (n-t (count 't res :key #'third))
                   (n-nil (count 'nil res :key #'third))
                   (expected (cond ((zerop n-t) nil)
                                   ((zerop n-nil) t)
                                   (t :indeterminate)))
                   (tmp (multiple-value-bind (validp val)
                            (integer-interval-<-p i j k l)
                          (if validp val :indeterminate))))
              (format t "[~D,~D] [~D,~D] ~:S ~:S => ~:S ~S ~S ~A~%" i j k l lhs rhs res
                      expected tmp (if (eql expected tmp) "OK" "***ERROR***")))))))))

(defun fold-fixnum-< (form)
  (let ((lhs (first (arguments form)))
        (rhs (second (arguments form))))
    (multiple-value-bind (lhs-valid-p lhs-lower-bound lhs-upper-bound)
        (extract-integer-type-interval lhs)
      (multiple-value-bind (rhs-valid-p rhs-lower-bound rhs-upper-bound)
          (extract-integer-type-interval rhs)
        (when (and lhs-valid-p
                   (integerp lhs-lower-bound)
                   (integerp lhs-upper-bound)
                   rhs-valid-p
                   (integerp rhs-lower-bound)
                   (integerp rhs-upper-bound))
          (multiple-value-bind (validp value)
              (integer-interval-<-p
               lhs-lower-bound lhs-upper-bound
               rhs-lower-bound rhs-upper-bound)
            (when validp
              (change-made)
              (ast `(progn ,lhs ,rhs ',value) form))))))))

(defmethod simp-form ((form ast-call))
  ;; Simplify arguments.
  (do ((i (arguments form) (cdr i)))
      ((endp i))
    (setf (car i) (simp-form (hoist-the-form-to-edge (car i)))))
  (cond ((eql (name form) 'eql)
         (simp-eql form))
        ((and (eql (name form) 'eq)
              (eql (length (arguments form)) 2)
              (eql (first (arguments form)) (second (arguments form))))
         ;; (eq X X) => T
         (change-made)
         (ast ''t form))
        ((eql (name form) 'ash)
         (simp-ash form))
        ((and (eql (name form) 'eq)
              (match-optimize-settings form '((= safety 0) (= speed 3)))
              (eql (length (arguments form)) 2)
              (typep (first (arguments form)) 'ast-the)
              (compiler-type-equal-p (ast-the-type (first (arguments form)))
                                     '(unsigned-byte 64))
              (quoted-form-p (second (arguments form)))
              (integerp (value (second (arguments form)))))
         ;; Transform (EQ (THE UB64 val) 'INTEGER) to %UB64-=
         (change-made)
         (ast `(call mezzano.runtime::%ub64-=
                     ,(first (arguments form))
                     ,(second (arguments form)))
              form))
        ((and (eql (name form) 'array-rank)
              (eql (length (arguments form)) 1)
              (match-optimize-settings form '((= safety 0) (= speed 3))))
         (simp-array-rank form))
        ((and (eql (name form) 'array-dimension)
              (eql (length (arguments form)) 2)
              (match-optimize-settings form '((= safety 0) (= speed 3))))
         (simp-array-dimension form))
        ((and (member (name form) '(sys.int::binary-logand %fast-fixnum-logand))
              (eql (length (arguments form)) 2)
              (match-optimize-settings form '((= safety 0) (= speed 3))))
         (simp-logand form))
        ;; (%coerce-to-callable 'foo) => #'foo
        ((and (eql (name form) 'sys.int::%coerce-to-callable)
              (eql (length (arguments form)) 1)
              (typep (unwrap-the (first (arguments form))) 'ast-quote)
              (symbolp (value (unwrap-the (first (arguments form))))))
         (change-made)
         (ast `(function ,(value (unwrap-the (first (arguments form)))))
              form))
        ;; (%coerce-to-callable #'foo) => #'foo
        ((and (eql (name form) 'sys.int::%coerce-to-callable)
              (eql (length (arguments form)) 1)
              (typep (unwrap-the (first (arguments form))) 'ast-function))
         (change-made)
         (first (arguments form)))
        ;; (%coerce-to-callable (lambda ...)) => (lambda ...)
        ((and (eql (name form) 'sys.int::%coerce-to-callable)
              (eql (length (arguments form)) 1)
              (typep (unwrap-the (first (arguments form))) 'lambda-information))
         (change-made)
         (first (arguments form)))
        ;; (%coerce-to-callable '#<function>) => #<function>
        ((and (eql (name form) 'sys.int::%coerce-to-callable)
              (eql (length (arguments form)) 1)
              (typep (unwrap-the (first (arguments form))) 'ast-quote)
              (functionp (ast-value (unwrap-the (first (arguments form))))))
         (change-made)
         (first (arguments form)))
        ;; (%apply #'foo (list ...)) => (foo ...)
        ((and (eql (name form) 'mezzano.runtime::%apply)
              (eql (length (arguments form)) 2))
         (simp-%apply form))
        ;; (%funcall #'name ...) -> (name ...)
        ((and (eql (name form) 'mezzano.runtime::%funcall)
              (typep (unwrap-the (first (arguments form))) 'ast-function))
         (change-made)
         (ast `(call ,(name (unwrap-the (first (arguments form))))
                     ,@(rest (arguments form))) form))
        ;; (funcall fn ...) = (%funcall (%coerce-to-callable fn) ...)
        ((and (eql (name form) 'funcall)
              (consp (arguments form)))
         (change-made)
         (ast `(call mezzano.runtime::%funcall
                     (call sys.int::%coerce-to-callable
                           ,(first (arguments form)))
                     ,@(rest (arguments form)))
              form))
        ;; (list ...) => (cons ... NIL)
        ((eql (name form) 'list)
         (change-made)
         (let ((inner (ast `(quote nil) form)))
           (loop
              for arg in (reverse (arguments form))
              do (setf inner (ast `(call cons ,arg ,inner) form)))
           inner))
        ;; (list* ... x) => (cons ... x)
        ((and (eql (name form) 'list*)
              (arguments form))
         (change-made)
         (let ((inner (first (last (arguments form)))))
           (loop
              for arg in (reverse (butlast (arguments form)))
              do (setf inner (ast `(call cons ,arg ,inner) form)))
           inner))
        ;; (%struct-slot s 'def 'slot) => fast-reader
        ((and (eql (name form) 'sys.int::%struct-slot)
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 3)
              (find-struct-slot (second (arguments form)) (third (arguments form))))
         (simplify-struct-slot form))
        ;; ((setf %struct-slot) value s 'def 'slot) => fast-writer
        ((and (equal (name form) '(setf sys.int::%struct-slot))
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 4)
              (find-struct-slot (third (arguments form)) (fourth (arguments form))))
         (simplify-setf-struct-slot form))
        ;; ((cas %struct-slot) old new s 'def 'slot) => fast-cas
        ((and (equal (name form) '(sys.int::cas sys.int::%struct-slot))
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 5)
              (find-struct-slot (fourth (arguments form)) (fifth (arguments form))))
         (simplify-cas-struct-slot form))
        ;; (%atomic-fixnum-add-struct-slot object 'struct-name 'slot-name value)
        ((and (member (name form) '(sys.int::%atomic-fixnum-add-struct-slot
                                    sys.int::%atomic-fixnum-logand-struct-slot
                                    sys.int::%atomic-fixnum-logior-struct-slot
                                    sys.int::%atomic-fixnum-logxor-struct-slot))
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 4)
              (test-atomic-fixnum-op-struct-slot-transform-viability form))
         (simplify-atomic-fixnum-op-struct-slot form))
        ;; (%atomic-swap-struct-slot object 'struct-name 'slot-name value)
        ((and (eql (name form) 'sys.int::%atomic-swap-struct-slot)
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 4)
              (test-atomic-swap-struct-slot-transform-viability form))
         (simplify-atomic-swap-struct-slot form))
        ;; (%dcas-struct-slot object 'struct-1 'slot-1 'struct-2 'slot-2 old-1 old-2 new-1 new-2) => fast-dcas
        ((and (equal (name form) 'sys.int::%dcas-struct-slot)
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 9)
              (test-dcas-struct-slot-transform-viability
               (second (arguments form)) (third (arguments form))
               (fourth (arguments form)) (fifth (arguments form))))
         (simplify-dcas-struct-slot form))
        ;; (%struct-vector-slot s 'def 'slot index) => fast-reader
        ((and (eql (name form) 'sys.int::%struct-vector-slot)
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 4)
              (find-struct-slot (second (arguments form)) (third (arguments form))))
         (simplify-struct-vector-slot form))
        ;; ((setf %struct-vector-slot) value s 'def 'slot index) => fast-writer
        ((and (equal (name form) '(setf sys.int::%struct-vector-slot))
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 5)
              (find-struct-slot (third (arguments form)) (fourth (arguments form))))
         (simplify-setf-struct-vector-slot form))
        ;; ((cas %struct-vector-slot) old new s 'def 'slot index) => fast-cas
        ((and (equal (name form) '(sys.int::cas sys.int::%struct-vector-slot))
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 6)
              (find-struct-slot (fourth (arguments form)) (fifth (arguments form))))
         (simplify-cas-struct-vector-slot form))
        ;; (%allocate-struct 'name) => (%allocate-struct 'struct)
        ((and (eql (name form) 'sys.int::%allocate-struct)
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 1)
              (typep (first (arguments form)) 'ast-quote)
              (symbolp (ast-value (first (arguments form))))
              (sys.int::get-structure-type (ast-value (first (arguments form))) nil))
         (change-made)
         (ast `(call sys.int::%allocate-struct ',(sys.int::get-structure-type (ast-value (first (arguments form)))))
              form))
        ((and (eql (name form) 'mezzano.runtime::%fixnum-<)
              (local-inlining-permitted-p form)
              (= (length (arguments form)) 2)
              (match-optimize-settings form '((= safety 0) (= speed 3)))
              (fold-fixnum-< form)))
        ((and (eql (name form) 'byte-size)
              (eql (length (arguments form)) 1)
              (typep (first (arguments form)) 'ast-call)
              (eql (ast-name (first (arguments form))) 'byte)
              (eql (length (arguments (first (arguments form)))) 2))
         ;; (byte-size (byte size position)) => (prog1 size position)
         (change-made)
         (ast `(let ((size ,(first (arguments (first (arguments form))))))
                 (progn
                   ,(second (arguments (first (arguments form))))
                   size))
              form))
        ((and (eql (name form) 'byte-position)
              (eql (length (arguments form)) 1)
              (typep (first (arguments form)) 'ast-call)
              (eql (ast-name (first (arguments form))) 'byte)
              (eql (length (arguments (first (arguments form)))) 2))
         ;; (byte-position (byte size position)) => (progn size position)
         (change-made)
         (ast `(progn
                   ,(first (arguments (first (arguments form))))
                   ,(second (arguments (first (arguments form)))))
              form))
        (t
         ;; Rewrite (foo ... ([progn,let] x y) ...) to ([progn,let] x (foo ... y ...)) when possible.
         (loop
            for arg-position from 0
            for arg in (arguments form)
            for type = (unwrapped-the-type arg)
            for unwrapped-arg = (unwrap-the arg)
            when (typep unwrapped-arg 'ast-progn)
            do
              (change-made)
              (return-from simp-form
                (simp-form
                 (ast `(progn
                         ,@(butlast (ast-forms unwrapped-arg))
                         (call ,(ast-name form)
                               ,@(subseq (arguments form) 0 arg-position)
                               (the ,type ,(first (last (ast-forms unwrapped-arg))))
                               ,@(subseq (arguments form) (1+ arg-position))))
                      form)))
            when (and (typep unwrapped-arg 'ast-let)
                      (not (let-binds-special-variable-p unwrapped-arg)))
            do
              (change-made)
              (return-from simp-form
                (simp-form
                 (ast `(let ,(ast-bindings unwrapped-arg)
                         (call ,(ast-name form)
                               ,@(subseq (arguments form) 0 arg-position)
                               (the ,type ,(ast-body unwrapped-arg))
                               ,@(subseq (arguments form) (1+ arg-position))))
                      form)))
            ;; Bail when a non-pure arg is seen. Arguments after this one can't safely be hoisted.
            when (not (pure-p unwrapped-arg))
            do (return))
         form)))

(defmethod simp-form ((form ast-jump-table))
  (setf (value form) (simp-form (value form)))
  (setf (targets form) (mapcar #'simp-form (targets form)))
  (cond ((and (typep (value form) 'ast-quote)
              (typep (value (value form)) 'integer)
              (<= 0 (value (value form)) (1- (length (targets form)))))
         (change-made)
         (elt (targets form) (value (value form))))
        (t
         form)))

(defmethod simp-form ((form lexical-variable))
  form)

(defmethod simp-form ((form lambda-information))
  (let ((*current-lambda* form))
    (dolist (arg (lambda-information-optional-args form))
      (setf (second arg) (simp-form (second arg))))
    (dolist (arg (lambda-information-key-args form))
      (setf (second arg) (simp-form (second arg))))
    (setf (lambda-information-body form) (simp-form (lambda-information-body form))))
  form)
